home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch19 / Pline3d.cls < prev    next >
Text File  |  1999-07-12  |  8KB  |  282 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "Polyline3d"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = False
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. ' Point3D and Segment3D are defined in module M3OPS.BAS as:
  17. '    Type Point3D
  18. '        coord(1 To 4) As Single
  19. '        trans(1 To 4) As Single
  20. '    End Type
  21. '
  22. '    Type Segment3D
  23. '        pt1 As Integer
  24. '        pt2 As Integer
  25. '    End Type
  26.  
  27. Public NumPoints As Integer  ' Number of points.
  28. Private Points() As Point3D  ' Data points.
  29.  
  30. Public NumSegs As Integer    ' Number of segments.
  31. Private Segs() As Segment3D  ' The segments.
  32.  
  33. ' Add a new segment when we know the point numbers.
  34. Public Sub AddNewSegment(ByVal pt1 As Integer, ByVal pt2 As Integer)
  35.     NumSegs = NumSegs + 1
  36.     ReDim Preserve Segs(1 To NumSegs)
  37.  
  38.     Segs(NumSegs).pt1 = pt1
  39.     Segs(NumSegs).pt2 = pt2
  40. End Sub
  41. ' Add a new point when we know it is not already here.
  42. Public Sub AddNewPoint(ByVal X As Single, ByVal Y As Single, ByVal Z As Single)
  43.     ' Create the new point.
  44.     NumPoints = NumPoints + 1
  45.     ReDim Preserve Points(1 To NumPoints)
  46.     Points(NumPoints).coord(1) = X
  47.     Points(NumPoints).coord(2) = Y
  48.     Points(NumPoints).coord(3) = Z
  49.     Points(NumPoints).coord(4) = 1#
  50. End Sub
  51.  
  52. ' Verify that the points in this solid are the same
  53. ' distance from the origin and that all segments
  54. ' are the same length.
  55. Public Function SolidOk() As Boolean
  56. Const TINY = 0.0001
  57. Dim i As Integer
  58. Dim dx As Single
  59. Dim dy As Single
  60. Dim dz As Single
  61. Dim dist_squared As Single
  62.  
  63.     ' Verify that all the segments have the
  64.     ' same length.
  65.     dx = Points(Segs(1).pt1).coord(1) - Points(Segs(1).pt2).coord(1)
  66.     dy = Points(Segs(1).pt1).coord(2) - Points(Segs(1).pt2).coord(2)
  67.     dz = Points(Segs(1).pt1).coord(3) - Points(Segs(1).pt2).coord(3)
  68.     dist_squared = dx * dx + dy * dy + dz * dz
  69.     For i = 2 To NumSegs
  70.         dx = Points(Segs(i).pt1).coord(1) - Points(Segs(i).pt2).coord(1)
  71.         dy = Points(Segs(i).pt1).coord(2) - Points(Segs(i).pt2).coord(2)
  72.         dz = Points(Segs(i).pt1).coord(3) - Points(Segs(i).pt2).coord(3)
  73.         If Abs(dist_squared - (dx * dx + dy * dy + dz * dz)) > TINY Then
  74.             SolidOk = False
  75.             Exit Function
  76.         End If
  77.     Next i
  78.  
  79.     ' Verify that all the points are the same
  80.     ' distance from the origin.
  81.     dist_squared = _
  82.         Points(1).coord(1) * Points(1).coord(1) + _
  83.         Points(1).coord(2) * Points(1).coord(2) + _
  84.         Points(1).coord(3) * Points(1).coord(3)
  85.     For i = 2 To NumPoints
  86.         If Abs(dist_squared - ( _
  87.             Points(1).coord(1) * Points(1).coord(1) + _
  88.             Points(1).coord(2) * Points(1).coord(2) + _
  89.             Points(1).coord(3) * Points(1).coord(3))) > TINY _
  90.         Then
  91.             SolidOk = False
  92.             Exit Function
  93.         End If
  94.     Next i
  95.  
  96.     SolidOk = True
  97. End Function
  98. ' Create a pyramid with height L and base given
  99. ' by the points in the coord array. Add the
  100. ' segments that make up the pyramid to this
  101. ' polyline.
  102. Public Sub Stellate(L As Single, ParamArray coord() As Variant)
  103. Dim x0 As Single
  104. Dim y0 As Single
  105. Dim z0 As Single
  106. Dim x1 As Single
  107. Dim y1 As Single
  108. Dim z1 As Single
  109. Dim x2 As Single
  110. Dim y2 As Single
  111. Dim z2 As Single
  112. Dim x3 As Single
  113. Dim y3 As Single
  114. Dim z3 As Single
  115. Dim Ax As Single
  116. Dim Ay As Single
  117. Dim Az As Single
  118. Dim Bx As Single
  119. Dim By As Single
  120. Dim Bz As Single
  121. Dim Nx As Single
  122. Dim Ny As Single
  123. Dim Nz As Single
  124. Dim num As Integer
  125. Dim i As Integer
  126. Dim pt As Integer
  127.  
  128.     num = (UBound(coord) + 1) \ 3
  129.     If num < 3 Then
  130.         MsgBox "Must have at least 3 points to stellate.", , vbExclamation
  131.         Exit Sub
  132.     End If
  133.     
  134.     ' (x0, y0, z0) is the center of the polygon.
  135.     x0 = 0
  136.     y0 = 0
  137.     z0 = 0
  138.     pt = 0
  139.     For i = 1 To num
  140.         x0 = x0 + coord(pt)
  141.         y0 = y0 + coord(pt + 1)
  142.         z0 = z0 + coord(pt + 2)
  143.         pt = pt + 3
  144.     Next i
  145.     x0 = x0 / num
  146.     y0 = y0 / num
  147.     z0 = z0 / num
  148.     
  149.     ' Find the normal.
  150.     x1 = coord(0)
  151.     y1 = coord(1)
  152.     z1 = coord(2)
  153.     x2 = coord(3)
  154.     y2 = coord(4)
  155.     z2 = coord(5)
  156.     x3 = coord(6)
  157.     y3 = coord(7)
  158.     z3 = coord(8)
  159.     Ax = x2 - x1
  160.     Ay = y2 - y1
  161.     Az = z2 - z1
  162.     Bx = x3 - x2
  163.     By = y3 - y2
  164.     Bz = z3 - z2
  165.     m3Cross Nx, Ny, Nz, Ax, Ay, Az, Bx, By, Bz
  166.     
  167.     ' Give the normal length L.
  168.     m3SizeVector L, Nx, Ny, Nz
  169.     
  170.     ' The normal + <x0, y0, z0> gives the point.
  171.     x0 = x0 + Nx
  172.     y0 = y0 + Ny
  173.     z0 = z0 + Nz
  174.  
  175.     ' Build the segments that make up the object.
  176.     x1 = coord(3 * num - 3)
  177.     y1 = coord(3 * num - 2)
  178.     z1 = coord(3 * num - 1)
  179.     pt = 0
  180.     For i = 1 To num
  181.         x2 = coord(pt)
  182.         y2 = coord(pt + 1)
  183.         z2 = coord(pt + 2)
  184.         AddSegment x1, y1, z1, x2, y2, z2, x0, y0, z0
  185.         x1 = x2
  186.         y1 = y2
  187.         z1 = z2
  188.         pt = pt + 3
  189.     Next i
  190. End Sub
  191.  
  192. ' Add one or more line segments to the polyline.
  193. Public Sub AddSegment(ParamArray coord() As Variant)
  194. Dim num_segs As Integer
  195. Dim i As Integer
  196. Dim last As Integer
  197. Dim pt As Integer
  198.  
  199.     num_segs = (UBound(coord) + 1) \ 3 - 1
  200.     ReDim Preserve Segs(1 To NumSegs + num_segs)
  201.  
  202.     last = AddPoint((coord(0)), (coord(1)), (coord(2)))
  203.     pt = 0
  204.     For i = 1 To num_segs
  205.         Segs(NumSegs + i).pt1 = last
  206.         pt = pt + 3
  207.         last = AddPoint((coord(pt)), (coord(pt + 1)), (coord(pt + 2)))
  208.         Segs(NumSegs + i).pt2 = last
  209.     Next i
  210.  
  211.     NumSegs = NumSegs + num_segs
  212. End Sub
  213. ' Add a point to the polyline or reuse a point.
  214. ' Return the point's index.
  215. Public Function AddPoint(ByVal X As Single, ByVal Y As Single, ByVal Z As Single) As Integer
  216. Dim i As Integer
  217.  
  218.     ' See if the point is already here.
  219.     For i = 1 To NumPoints
  220.         If X = Points(i).coord(1) And _
  221.            Y = Points(i).coord(2) And _
  222.            Z = Points(i).coord(3) Then _
  223.                 Exit For
  224.     Next i
  225.     AddPoint = i
  226.     
  227.     ' If so, we're done.
  228.     If i <= NumPoints Then Exit Function
  229.     
  230.     ' Otherwise create the new point.
  231.     NumPoints = NumPoints + 1
  232.     ReDim Preserve Points(1 To NumPoints)
  233.     Points(i).coord(1) = X
  234.     Points(i).coord(2) = Y
  235.     Points(i).coord(3) = Z
  236.     Points(i).coord(4) = 1#
  237. End Function
  238.  
  239. ' Apply a transformation matrix which may not
  240. ' contain 0, 0, 0, 1 in the last column to the
  241. ' object.
  242. Public Sub ApplyFull(M() As Single)
  243. Dim i As Integer
  244.  
  245.     For i = 1 To NumPoints
  246.         m3ApplyFull Points(i).coord, M, Points(i).trans
  247.     Next i
  248. End Sub
  249.  
  250. ' Apply a transformation matrix to the object.
  251. Public Sub Apply(M() As Single)
  252. Dim i As Integer
  253.  
  254.     For i = 1 To NumPoints
  255.         m3Apply Points(i).coord, M, Points(i).trans
  256.     Next i
  257. End Sub
  258.  
  259.  
  260. ' Draw the transformed points on a PictureBox.
  261. Public Sub Draw(ByVal pic As PictureBox, Optional R As Variant)
  262. Dim seg As Integer
  263. Dim pt1 As Integer
  264. Dim pt2 As Integer
  265. Dim dist As Single
  266.  
  267.     On Error Resume Next
  268.     If IsMissing(R) Then R = INFINITY
  269.     dist = R
  270.     For seg = 1 To NumSegs
  271.         pt1 = Segs(seg).pt1
  272.         pt2 = Segs(seg).pt2
  273.         ' Don't draw if either point is farther
  274.         ' from the focus point than the center of
  275.         ' projection (which is distance dist away).
  276.         If (Points(pt1).trans(3) < R) And (Points(pt2).trans(3) < R) Then _
  277.             pic.Line _
  278.                 (Points(pt1).trans(1), Points(pt1).trans(2))- _
  279.                 (Points(pt2).trans(1), Points(pt2).trans(2))
  280.     Next seg
  281. End Sub
  282.